#|_____________________________________________________________________
 | dashobj0.lsp 
 |                    
 |                      Iconized DataSheet Manager
 |              Copyright (c) 2001-2002 by Forrest W. Young
 |
 | Contains functions to browse and edit the current iconized datasheet,
 | code for the databuffer object, and set-current-datasheet function.
 |_____________________________________________________________________
 |#


#|_____________________________________________________________________
 |
 | MENU ITEM FUNCTIONS, CONSTRUCTOR FUNCTIONS AND PROTOTYPE CODE FOR
 | 
 |                  ENTER-DATA, BROWSE-DATA, EDIT-DATA
 |
 |            DATA-SUPERVISOR-PROTO, DISS-DATA-SUPERVISOR-PROTO
 |_____________________________________________________________________
 |#



(defun ENTER-DATA (&key (size '(500 250)) (location nil) (shrink-wrap nil) (show t) )
"Args: &key (size '(500 250)) (location nil) (shrink-wrap nil) (show t) 
Menu item function to place a datasheet icon on the workmap and to open an empty editable datasheet."
  (edit-data :data nil :editable t :size size :location location :shrink-wrap shrink-wrap))

(defun BROWSE-DATA (&key (data $) (size '(500 250)) (location nil) (shrink-wrap nil) (show t) )
"Args: &key (data $) (size '(500 250)) (location nil) (shrink-wrap nil) (show t) 
Menu item function to open an uneditable datasheet in a window with a menubar."
  (edit-data :data data :size size :location location 
                         :shrink-wrap shrink-wrap :editable nil))


(defun EDIT-DATA (&key (data $) (freq nil) (show t) (editable t) (info nil)
                       (size '(500 250)) (location nil) (shrink-wrap t)
                       (in nil))
	
"Arg: &key (&key (data $) (freq nil) (show t) (editable t) (info nil) (size '(500 250)) (location nil) (shrink-wrap t) (in nil))
Menu item function to open a datasheet for editing DATA. If DATA is not NIL (the default) the datasheet uses a copy of DATA so that he original DATA remain untouched. If Data is specified as NIL, then the data are treated as if they are NEW (i.e., undefined), and a datasheet with missing or zero elements in it will be displayed. Datasheet will be optimally located unless location is specified. When datasheet are not editable (i.e., when they are browseable) the datasheet is contained within a container IN which has a menubar. "
  (let* ((newdata nil)
         (menu-bar  (not editable))
         (dataflag  (if data t nil))
         (result    (unless dataflag (new-data-dialog2)))
         (quit?     (if (and (not dataflag) (not result)) (top-level)))
         (name      (if dataflag (send data :name) (first result)))
         ;(name.dsh  (concatenate-version name "dsh"))
         (names.dsh (make-names name "dsh"))
        ; (a (one-button-dialog (format nil "~a ~a" name names.dsh)))
         (datatype  (if dataflag (send data :generalized-datatype)
                        (case (second result) (0 "freq") (1 "matrix") (2 nil))))
         (freq      (if freq freq (equal datatype "freq")))
         (row-label (if freq (if dataflag (send data :labels) (third result)) nil))
         (col-label (if freq (if dataflag (send data :variables) (fourth result)) nil))
;following statement produces a buffer dataobject named name.buf#1
;which is iconized with a dash icon on the workmap with title name.dsh#1
         ; (a (one-button-dialog (format nil "~a ~a" name names.dsh)))
         (fauxdata  (if editable
                        (dash-iconized-data
                         :known-as (strcat name
                                           (if (equal (sixth names.dsh) " ")
                                               ".dsh "
                                               (format nil ".dsh#~a" (sixth names.dsh))))
                        ;:known-as (third names.dsh)  ;   propername.dsh
                         :name name                   ;   dataset.buf
                         :dataobj data
                         :creator t
                         :datatype datatype 
                         :row-label row-label 
                         :column-label col-label
                         )
                        data))
         ;(a (one-button-dialog (format nil "~a ~a" name names.dsh)))
         (location   (if location location (dash-locator)))
         (button-bar t)
         (menu-bar   (when menu-bar
                           (dash-menubar :editable editable :size '(550 250)))) 
;following statement produces a datasheet window and object 
;which is named name.dash#n+1. this object becomes *current-datasheet*
         (dash       (send fauxdata 
                           :make-datasheet
                           :names names.dsh 
                           :editable editable
                           :row-label row-label 
                           :column-label col-label 
                           :info info 
                           :show menu-bar
                          ; :pop-out nil
                           :size (when menu-bar (screen-size) size )
                           :location (if menu-bar '(2000 2000) location)
                           :shrink-wrap  shrink-wrap ;(when menu-bar nil shrink-wrap)
                           :menu-bar     menu-bar
                           :in           menu-bar 
                           :in-used?     menu-bar 
                           :pop-out     (not menu-bar)
                           :button-bar   button-bar))
         )
    (send dash :supervisor (if editable fauxdata nil))
    ;following statement added by fwy 09-05-02
    (send dash :dob-parents (if editable (list data) (list nil)))

    (when menu-bar
          (send dash :size 
                (max (+ (first (screen-size)) 8)
                     (+ (send dash :label-width) 
                        (* (send dash :nvar) (send dash :field-width))))
                (max (+ (second (screen-size)) 100) 
                        (* (+ (send dash :nobs) 2) (send dash :field-height))))
          (send menu-bar :has-v-scroll (* (+ (send dash :nobs) 2) (send dash :field-height)))
          (send menu-bar :has-h-scroll (+ (send dash :label-width) 
                                          (* (send dash :nvar) (send dash :field-width))))
	  (send dash :location 1 24)
          (send menu-bar :title (send dash :title))
	  (send menu-bar :location 50 50)
          (send menu-bar :size 550 250)
          (send menu-bar :show-window)
          )
    (when (not menu-bar)
          (send dash :show-window))
    (send dash :title (strcat "DataSheet - " (send dash :proper-name)))
    (send dash :info)
    dash))

(defun new-data-dialog2 ()
  (flet ((suggested-name (name rowname colname case) 
                (case (send case :value)
                  (0 (send name :text "NewFreqData")
                     (send rowname :text "Row")
                     (send colname :text "Column"))
                  (1 (send name :text "NewMatData")
                     (send rowname :text " ")
                     (send colname :text " "))
                  (2 (send name :text "NewData")
                     (send rowname :text " ")
                     (send colname :text " ")))))
    (let* ((txt1 (send text-item-proto :new "Which DataType?"))
           (type (send choice-item-proto :new
                       '( "Frequency Table Data" 
                          "Matrix Data"
                          "All Other Types" 
                          )
                       :value 2))
           (txt2 (send text-item-proto :new "The New Data Will Be Named:"))
           (name (send edit-text-item-proto :new "NewData" :text-length 21))
           (freq (send text-item-proto :new 
                 (format nil "FOR FREQUENCY DATA, ENTER ROW AND COLUMN NAMES~%(Leave one label blank for one-way data):")))
           (rowtxt (send text-item-proto :new "Row Label:"))
           (coltxt (send text-item-proto :new "Column Label:"))
           (rowname (send edit-text-item-proto :new " " :text-length 24))
           (colname (send edit-text-item-proto :new " " :text-length 24))
           (colstring "Col")
           (dummy (defmeth type :do-action ()
                    (suggested-name name rowname colname type)))
           (HELP (send modal-button-proto :new "Help" 
                       :action #'(lambda ()
                                   (new-data-help)
                                   nil))) ;(list (send name :text) 6)
           (OK   (send modal-button-proto :new "OK" 
                       :action #'(lambda () 
                                   (list (send name :text) 
                                         (send type :value)
                                         (send rowname :text)
                                         (send colname :text)))))
           (cancel (send modal-button-proto :new "Cancel"))
           (dialog (send modal-dialog-proto :new
                         (list (list (list txt1 type ) 
                                     (list txt2 name))
                              ; freq
                              ; (list (list rowtxt coltxt)
                              ;       (list rowname colname))
                               (list OK cancel help)
                               )
                         :title "New Data Dialog"
                         :default-button OK))
           (return (send dialog :modal-dialog))
           )
      return)))


(defun dash-locator ()
  (let* ((desk-loc   (send *desktop-container* :frame-location))
         (scroll     (send *workmap* :scroll))
         (location  
          (cond
            ((and *desktop-container* (send *desktop-container* :showing))
             (list
              (+ (send (send *workmap* :selected-icon-object) :x) 
                 100
                 (- (first scroll))
                 (first desk-loc))
              (+ (send (send *workmap* :selected-icon-object) :y) 
                 88
                 (- (second scroll))
                 (second desk-loc))))
            (t
             (list 100 100)))))
    location))




#|_____________________________________________________________________
 |
 | CURRENT-DATASUPERVISOR
 |_____________________________________________________________________
 |#

(setf *current-datasupervisor* nil)
(setf  current-datasupervisor nil)
(setf *cdsupr* nil)
(setf  cdsupr  nil)
(setf *cdsp* nil)
(setf  cdsp  nil)
(setf *cdm* nil)
(setf  cdm  nil)
(setf *cdman* nil)
(setf  cdman  nil)


(defun set-current-data-supervisor (&optional (object nil object?) &key (update-workmap t))
  (if object?
      (send object :set-current-datasupervisor object :update-workmap update-workmap)
      (send object :set-current-datasupervisor )
      ))

(defun set-current-datasupervisor (&optional (object nil object?) &key (update-workmap t))
  (if object?
      (send object :set-current-datasupervisor object :update-workmap update-workmap)
      (send object :set-current-datasupervisor )
      ))

(defun setcdsp (&optional (object nil object?) &key (update-workmap t))
  (if object?
      (send object :set-current-datasupervisor object :update-workmap update-workmap)
      (send object :set-current-datasupervisor )
      ))

(defun setcdm (&optional (object nil object?) &key (update-workmap t))
  (if object?
      (send object :set-current-datasupervisor object :update-workmap update-workmap)
      (send object :set-current-datasupervisor )
      ))


(defun set-current-databuffer (&optional (object nil object?) &key (update-workmap t))
  (if object?
      (send object :set-current-datasupervisor object :update-workmap update-workmap)
      (send object :set-current-datasupervisor )
      ))


(defun setcdb (&optional (object nil object?) &key (update-workmap t))
  (if object?
      (send object :set-current-datasupervisor object :update-workmap update-workmap)
      (send object :set-current-datasupervisor )
      ))

(defun setcdsp-symbols (datasupervisor)
  (send datasupervisor :set-symbols))

(defun check-setcdsp (new-selected-icon)
  (terpri)(send new-selected-icon :print)
  (terpri)(send (send new-selected-icon :object) :print)
  (terpri)(send (send (send new-selected-icon :object) :datasheet) :print))



#|_____________________________________________________________________
 |
 | DEFPROTO DATA-SUPERVISOR-PROTO
 |_____________________________________________________________________
 |#

(defun dash-iconized-data (&Key (dataobj nil) (name nil) (datatype nil) (known-as nil)
                               (row-label nil) (column-label nil) (creator nil))
"Args: (&Key (dataobj nil) (name nil) (datatype nil) (known-as nil) (row-label nil) (column-label nil) (creator nil))
Constructor function for data objects that are iconized as datasheets. Copies DATAOBJ, if not NIL, or creates a new dataobj if it is NIL. Displays new object on workmap as a datasheet icon. Internally, calls the DATA function in one of four different ways, depending on whether a pre-existing data is being used, or new data are being created. In each case, the DATA function is called with the keyword ICONIFY set to a value of DATASHEET. This causes the DATA function to use the DATA-SUPERVISOR-PROTO rather than MV-DATA-OBJECT-PROTO, which forces the dash-iconized-data object to appear and act like a datasheet icon. The actions are created by giving it the proper symbols."
  (setf known-as (if known-as known-as name))
  (let* ((dash-iconized-data))
                          
                  
;for pre-existing data
    
    (cond 
      (dataobj
       (setf dash-iconized-data
             (data  name 
                   :known-as  known-as 
                   :data-type datatype
                   :iconify   "datasheet" 
                   :array     (send dataobj :array)
                   :freq      (send dataobj :freq)
                   :variables (send dataobj :active-variables '(all)) ; :variables
                   :types     (send dataobj :active-types '(all))     ; :types
                   :labels    (send dataobj :active-labels)
;fwy modified following to fix matrix data bug 09-27-02
                   :data      (if (equal datatype "matrix")
                                  (combine 
                                    (send dataobj :get-active-data-matrices));data-by-matrix
                                  (send dataobj :active-data '(all))) ; :data
                   :matrices  (if (equal datatype "matrix")
                                  (send dataobj :active-matrices '(all))
                                  nil)
                   :row-label    row-label
                   :column-label column-label
                   :created (if creator (send *desktop* :selected-icon) nil)
                   :info nil
                   ))
       )

;for new freq data

      ((equal datatype "freq")                             
       (let* ((col-label column-label)
              (nrows (if (> (length row-label) 0) 2 1))
              (ncols (if (> (length col-label) 0) 2 1))
              (colstring (if (equal col-label "Column") 
                             "Column" col-label))
              (var-names (list (strcat colstring "1")
                               (strcat colstring "2")))
              (obs-names (list (strcat row-label "1")
                               (strcat row-label "2")))
              (ndata (* nrows ncols))
              (vars (if (= 2 ncols) var-names (list (first var-names)))) 
              (rows (if (= 2 nrows) obs-names (list (first obs-names)))))
         (setf dash-iconized-data
               (data name 
                     :known-as  known-as ;(proper-name known-as "dsh")
                     :data-type "freq"
                     :iconify   "datasheet" 
                     :array      t 
                     :freq       t
                     :variables  vars 
                     :labels     rows
                     :data      '(0 0 0 0)
                     :row-label    '("Row1" "Row2")
                     :column-label '("Column1" "Column2")
                     :info nil
                     ;;; :data-editor t
                     ))
 
         ))

;for new matrix data

      ((equal datatype "matrix") 
       (setf dash-iconized-data
             (data name
                   :known-as  known-as ;(proper-name known-as "dsh")
                   :data-type "matrix" 
                   :iconify   "datasheet"
                   :variables '("RowCol1" "RowCol2")
                   :labels    '("RowCol1  " "RowCol2  ")
                   :data      '(NIL NIL NIL NIL)
                   :shapes    '("Symmetric")
                   :matrices  '("Matrix1")
                   :info nil
                   ;;;:data-editor t
                   )))                                                                             

;for new other data


      (t
             
       (setf dash-iconized-data
             (data name 
                   :known-as  known-as ;(proper-name known-as "dsh")
                   :data-type "new"  
                   :iconify   "datasheet"
                   :variables '("Var1" "Var2")
                   :labels    '("Obs1" "Obs2")
                   :types     '("Category" "Category")
                   :data      '("---" "---" "---" "---")
                   :info nil
                   ;; :data-editor t
                   ))))

    (setcdm dash-iconized-data)
    )
  )
         

(defproto data-supervisor-proto '( ) () mv-data-object-proto)

(defmeth data-supervisor-proto :isnew (&rest args)
  (apply #'call-next-method args)
 ; (send self :set-current-datasupervisor self)
   (send self :statistical-object-type "dash")
  self)

(defmeth data-supervisor-proto :statistical-object-type (&optional (logical nil set))
;written this way to prevent changing slot to invalid value
    (setf (slot-value 'statistical-object-type) "dash")
    (slot-value 'statistical-object-type))

(defmeth data-supervisor-proto :make-datasheet (&rest args)
  (apply #'call-next-method (append args (list :supervisor t))))

(defmeth mv-data-object-proto :make-datasheet 
  (&key (in nil in?) (in-used? nil) (info t) (show t) (editable t)
        (size '(500 250)) (location '(100 100)) (shrink-wrap nil) 
        (row-label nil) (column-label nil) (pop-out t) (info nil)
        (button-bar nil) (menu-bar nil) (names nil)
        (has-v-scroll t) (has-h-scroll t) (supervisor nil))
  ;(print (list "dashobj0.lsp make-datasheet names=" names))
  (when *current-datasheet* (send *current-datasheet* :on-top nil))
  (let* ((name (send self :name))
         (freq (send self :freq))
         (datatype (send self :datatype))
         (location (if in-used? '(0 0) location))
         (dash (datasheet 
                self :name name :names names 
                :in in :in-used? in-used? :pop-out pop-out
                :editable editable :show t :shrink-wrap shrink-wrap :info info
                :title name :size size :location location :freq freq
                :supervisor supervisor)))
    (send dash :name (if names (first names) name))
    (when shrink-wrap         
          (send dash :shrink-wrap? t)
          (setf size (send dash :shrink-wrap)))
    (send dash :size-loc (combine size location))

    (let* ((item (send menu-item-proto :new (strcat "DataSheet - " (send dash :proper-name)))))
      (send *desktop-window-menu* :append-items item)
      (send item :add-slot 'datasheet dash) 
      (send dash :add-slot 'window-menu-item item)
      (defmeth  item :do-action ()
        (send (slot-value 'datasheet) :show-window)))
    
    (defmeth dash :close ()
      (send self :hide-window))

    (defmeth dash :hide-window ()
      (let* ((s (send self :size))
             (l (send self :location)))
        (send self :size-loc (combine s l))
	(send self :showing nil)
        (send self :location 3000 3000)))

    (defmeth dash :show-window ()
     ; (when *current-datasheet* (send *current-datasheet* :on-top nil))
      (let* ((size-loc (send self :size-loc))
             (menu-item (send self :dash-menu-top-item))
             )
        (send self :size-loc nil)
        (when size-loc
              (send self :location (third size-loc) (fourth size-loc))
              (send self :size     (first size-loc) (second size-loc)))
        (when pop-out (send self :pop-out t))
        (call-next-method)
	(send self :showing t)
        (send self :active-window)
        (send dash :redraw)))

    (defmeth dash :show-datasheet () (send dash :show-window))
    (defmeth dash :hide-datasheet () (send dash :hide-window))
    (if show (send dash :show-window))
    (send dash :dash-icon (send *workmap* :selected-icon-object))
    (send (send dash :dash-icon) :object dash)
    (send dash :editor self)
    (send self :datasheet dash)
    (setcds dash)
    dash))



(defmeth data-supervisor-proto :hide-datasheet ()
  (send (send self :datasheet) :hide-window))

(defmeth data-supervisor-proto :show-datasheet ()
  (send (send self :datasheet) :show-window))

(defmeth data-supervisor-proto :create-data ()
    (send (send self :datasheet) :create-data))

(defmeth data-supervisor-proto :save-data-on-workmap (&rest args)
  (send (send self :datasheet) :save-data-on-workmap))

(defmeth data-supervisor-proto :save-data-as ()
  (send (send self :datasheet) :save-data-as))
  


(defmeth data-supervisor-proto :set-current-datasupervisor (&optional (object nil object?) 
                                                                   &key (update-workmap t))
  (cond
    ((and (not object) object?)
     (set-current-data-variables nil)
     nil)
    ((not object) *current-datasupervisor*)
    (object
     (send self :set-current-data-variables)
     (send (send *vista* :var-window-object) :clear)
     (send (send *vista* :obs-window-object) :clear)
     ;(send self :set-menu&tool-states "Disabled");statement deleted fwy 09-05-02
     self)))

(defmeth data-supervisor-proto :setcdsp (&optional (object nil object?)
                                                  &key (update-workmap t))
  (if object?
      (send self :set-current-datasupervisor object :update-workmap update-workmap)
      (send self :set-current-datasupervisor :update-workmap update-workmap)
      ))

(defmeth data-supervisor-proto :set-current-data-variables ()
  (send self :set-symbols)
  (unless (send self :$)
          (when (send self :full-name)
                (set (intern (string-upcase (send self :full-name))) self))
          (when (send self :name)
                (set (intern (string-upcase (send self :name))) self ))
          (when (send self :proper-name)
                (set (intern (string-upcase (send self :proper-name))) self ))
          (send self :$ self)
          )
  (send self :full-name))

(defmeth data-supervisor-proto :set-symbols ()
  (setf *current-datasupervisor* self)
  (setf  current-datasupervisor  self)
  (setf  current-databuffer  self)
  (setf *current-databuffe*  self)
  (setf *cdsupr* self)
  (setf  cdsupr  self)
  (setf *cdsp*   self)
  (setf  cdsp    self)
  (setf *cdman*  self)
  (setf *cdm*    self)
  (setf  cdman   self)
  (setf  cdm     self)
  (setf *cdb*    self)
  (setf  cdbufr  self)
  (setf  cdb     self)
  (setf *co* self)
  (setf  co  self)
  (setf *current-object* self)
  (setf  current-object  self)
  (setf @ self)
  self)

(defmeth data-supervisor-proto :known-as (&optional (name-string))
  (call-next-method name-string))

  
(defmeth data-supervisor-proto :print (&rest args)
  (format t "~a" (send self :full-name)))
    
(defmeth data-supervisor-proto :window-menu-item  (&optional (objid nil set))
  (if set (setf (slot-value  'window-menu-item) objid))
  (slot-value 'window-menu-item))

(defmeth data-supervisor-proto :make-object-id (&key (subject nil)) 
  (format nil "#<~a: ~a   ;StatObj: ~a>"
          (if subject subject "Object")
          (if (send self :known-as)
              (send self :known-as)
              (send self :proper-name))
          (send self :make-vistatype)))

(defmeth data-supervisor-proto :make-vistatype ()
  (if (equal "matrix" (string-downcase (send self :data-type)))
      (format nil "DataBufr[~ax~a]" 
              (* (send self :nobs) (send self :nmat))
              (send self :nobs))
      (format nil "DataBufr[~ax~a]" (send self :nobs) (send self :nvar))))


(defmeth data-supervisor-proto :make-names (name)
  (let* ((temp (get-sob-extension  name))
         (version (third temp))
         (temp (second temp))
         (extension "buf")
         (proper-name (proper-name temp extension version))
         (full-name proper-name)
         (elipsis-name (elipsis-name full-name)))
    (send self :name temp)
    (send self :extension extension)
    (send self :full-name full-name)
    (send self :proper-name proper-name)
    (send self :elipsis-name (elipsis-name (send self :proper-name)))
  ;  (send self :name temp)
  ;  (send self :proper-name nil)
  ;  (send self :proper-name (send self :make-proper-name))
    (send self :full-name (send self :proper-name))
    (set (intern (string-upcase full-name)) self)
    (set (intern (string-upcase temp)) self)
    (set (intern (string-upcase proper-name)) self)
    (set (intern (string-upcase elipsis-name)) self)
    (send self :object-id nil)
    (send self :make-object-id)
    (send self :proper-name)))

(defmeth data-supervisor-proto :make-proper-name ()
    (proper-name (first (parse-name (send self :name))) "buf"))

(defmeth data-supervisor-proto :proper-name (&optional (str nil set))
   (when (not (slot-value 'proper-name)) 
         (slot-value 'proper-name (send self :make-proper-name)))
  (if set (setf (slot-value 'proper-name) str))
  (slot-value 'proper-name))
          
(defmeth data-supervisor-proto :info (&optional (stream *standard-output*)
                                               &key (verbose nil) (subject nil))
  (if (or *history* verbose)
      (unless (equal (string-downcase (send self :name)) "hidden")
              (format stream  "~%; ~a: Name:      ~a~%" 
                      (if subject subject "Object") 
                      (send self :proper-name))
              (format stream  ";         DataFile:  ~a~%" 
                      (if (not (send self :datafile))
                          (send self :datafile
                                (send *workmap* :datafile))
                          (if (send self :datafile)
                              (send self :datafile) 
                              "[Not Saved To File]")))
              (format stream  ";         StObjType:  ~a~%" (send self :make-vistatype))
              (format stream  ";         ProtoType: ~a~%" 
                      (string-capitalize 
                       (send self :slot-value 'proto-name)))
              (format stream  ";         Address:   ~d~%" (address-of self))
              (format stream  ";         Created:   ~a~%" 
                      (send self :slot-value 'instance-info))
              (format stream  ";         Elapsed:   ~,4d seconds~%" 
                      (fuzz (send self :elapsed-time) 3)))
        (format stream "; Buffer: ~a; ~a; ~,4d seconds~%> "
              (send self :proper-name) (send self :vistatype) 
                (fuzz (send self :elapsed-time) 3))))




(defmeth data-supervisor-proto :$vars () )